home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / TREEST.f < prev    next >
Text File  |  1992-07-31  |  5KB  |  140 lines
  1.       SUBROUTINE TREEST(MODE)   
  2. *-----------------------------------------------------------------------
  3. *   
  4. *--- Prepares TREE file output (called for each statement)  
  5. *   
  6. *---Input   
  7. *   MODE        =0 : headerless routine start   
  8. *               >0 : normal routine start, or statement 
  9. *-----------------------------------------------------------------------
  10.       include 'PARAM.h' 
  11.       include 'ALCAZA.h' 
  12.       include 'TREECOM.h' 
  13.       include 'STATE.h' 
  14.       include 'FLAGS.h' 
  15.       include 'CLASS.h' 
  16.       include 'CURSTA.h' 
  17.       CHARACTER SNAME*(MXNMCH),STEMP*1  
  18.       LOGICAL LEXARS
  19.       NCALLP=NCALLD 
  20.       IF(MODE.EQ.0)  THEN   
  21. *--- headerless routine start   
  22.          NCALLR=NCALLR+1
  23.          ICALLR(NCALLR)=0   
  24.          CALLER(NCALLR)=SCROUT  
  25.       ELSE  
  26. *--- external class number  
  27.          ICLE=ISTMDS(6,ICURCL(1))   
  28. *--- routine header or entry
  29.          IF(ISTMDS(14,ICURCL(1)).NE. 0.OR.ICLE.EQ.29) THEN  
  30.             IF(ICLE.EQ.29) THEN 
  31.                SNAME=SNAMES(ISNAME+1)   
  32.             ELSE
  33.                SNAME=SCROUT 
  34.             ENDIF   
  35. *--- keep argument name list
  36.             NARGEL=MAX(0,MIN(NSNAME-1,NOARG))   
  37.             DO 10 I=1,NARGEL
  38.                SARGEL(I)=SNAMES(ISNAME+I+1) 
  39.    10       CONTINUE
  40. *--- add routine name to list   
  41.             IF(NCALLR.LT.KENT) THEN 
  42. *--- keep statement ref. for callers
  43.                ICALLR(NCALLR+1)=NSTREF  
  44.                CALLER(NCALLR+1)=SNAME   
  45.                NCALLR=NCALLR+1  
  46.             ENDIF   
  47.          ELSEIF(ICLE.EQ.31) THEN
  48. *--- EXTERNAL statement - keep names
  49.             DO 20 I=1,NSNAME
  50.                IF(NEXEL.LT.KALL) THEN   
  51.                   NEXEL=NEXEL+1 
  52.                   SEXEL(NEXEL)=SNAMES(ISNAME+I) 
  53.                ENDIF
  54.    20       CONTINUE
  55.          ELSEIF(ISTMDS(11,ICURCL(1)).NE.0) THEN 
  56. *--- executable - scan all names
  57.             IF(ICURCL(1).EQ.IIF) THEN   
  58.                ICLE=ISTMDS(6,ICURCL(2)) 
  59.                IND=INDEX(SSTA,'(')  
  60.                CALL SKIPLV(SSTA,IND+1,NCHST,.FALSE., IPT,ILEV)  
  61.             ELSE
  62.                ICLE=ISTMDS(6,ICURCL(1)) 
  63.                IPT=0
  64.             ENDIF   
  65.             IF(ICLE.EQ.7) THEN  
  66. *--- subroutine call
  67.                DO 30 I=1,NSNAME 
  68.                   IF(NSSTRT(I).GT.IPT) GOTO 40  
  69.    30          CONTINUE 
  70.                GOTO 999 
  71.    40          CONTINUE 
  72. *--- keep name ref. of call 
  73.                ISTC=I   
  74. *--- check against argument list, drop if argument  
  75.                DO 50 J=1,NARGEL 
  76.                   IF(SNAMES(ISNAME+I).EQ.SARGEL(J)) GOTO 55 
  77.    50          CONTINUE 
  78.                IF(NCALLD.LT.KALL) THEN  
  79.                   NCALLD=NCALLD+1   
  80.                   CALLED(NCALLD)=SNAMES(ISNAME+I)   
  81.                   CEDARG(NCALLD)=' '
  82.                   IND=INDEX(SSTA(IPT+1:NCHST),'(')  
  83.                   IF(IND.GT.0) THEN 
  84.                      CALL ARGTYP(SSTA,.FALSE.,IPT+IND,NCHST,
  85.      +               CEDARG(NCALLD))
  86.                   ENDIF 
  87.                ENDIF
  88.             ELSE
  89.                ISTC=0   
  90.             ENDIF   
  91.    55       CONTINUE
  92.             DO 70 I=1,NSNAME
  93.                IF(I.EQ.ISTC) GOTO 70
  94.                IF((ITBIT(NAMTYP(ISNAME+I),17).NE.0  
  95.      +         .AND.SNAMES(ISNAME+I).NE.SCROUT) 
  96.      +         .OR.ITBIT(NAMTYP(ISNAME+I),12).NE.0) THEN
  97. *--- name is a function, or EXTERNAL
  98. *--- check against argument list, drop if argument  
  99.                   DO 60 J=1,NARGEL  
  100.                      IF(SNAMES(ISNAME+I).EQ.SARGEL(J)) GOTO 70  
  101.    60             CONTINUE  
  102.                   IF(NCALLD.LT.KALL) THEN   
  103.                      IPT=NSEND(I)+1 
  104.                      IF(LEXARS(I))  THEN
  105. *--- name appears as argument to another routine
  106.                         NCALLD=NCALLD+1 
  107.                         CALLED(NCALLD)=SNAMES(ISNAME+I) 
  108.                         CEDARG(NCALLD)='$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  109.      +$$$$$$$$$$$$$$$$$$'   
  110.                      ELSE   
  111.                         STEMP=SSTA(IPT:IPT) 
  112.                         IF(STEMP.EQ.' ') THEN   
  113.                            IPT=IPT+1
  114.                            STEMP=SSTA(IPT:IPT)  
  115.                         ENDIF   
  116.                         IF(STEMP.EQ.'(') THEN   
  117.                            CALL SKIPLV(SSTA,IPT+1,NCHST,.FALSE., IPOS,  
  118.      +                     ILEV)
  119.                            IF(IPOS.GT.0) THEN   
  120.                               NCALLD=NCALLD+1   
  121.                               CALLED(NCALLD)=SNAMES(ISNAME+I)   
  122.                               CEDARG(NCALLD)=' '
  123.                               CALL ARGTYP(SSTA,.FALSE.,IPT,IPOS,
  124.      +                        CEDARG(NCALLD))   
  125.                            ENDIF
  126.                         ENDIF   
  127.                      ENDIF  
  128.                   ENDIF 
  129.                ENDIF
  130.    70       CONTINUE
  131.          ENDIF  
  132.       ENDIF 
  133. *--- suppress multiple subsequent called routines with identical
  134. *    argument type lists
  135.       IF(NCALLP.GT.0.AND.NCALLD.GT.NCALLP)  THEN
  136.          IF(CALLED(NCALLD).EQ.CALLED(NCALLD-1)  
  137.      +   .AND.CEDARG(NCALLD).EQ.CEDARG(NCALLD-1))  NCALLD=NCALLD-1  
  138.       ENDIF 
  139.   999 END   
  140.